home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / intb.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  43.6 KB  |  1,836 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. /* Continuation of ada interpreter - auxiliary procedures */
  11.  
  12. /* Include standard header modules */
  13. #include <stdlib.h>
  14. #include <setjmp.h>
  15. #include "config.h"
  16. #include "int.h"
  17. #include "ivars.h"
  18. #include "machineprots.h"
  19. #include "farithprots.h"
  20. #include "taskingprots.h"
  21. #include "predefprots.h"
  22. #include "intcprots.h"
  23. #include "intbprots.h"
  24.  
  25. extern jmp_buf raise_env;
  26.  
  27. static void update_address(int *);
  28. static void image_attribute();
  29. static void value_attribute();
  30. static int same_dimensions(int *, int *);
  31. static int compare_fields_record(int *, int *, int *);
  32.  
  33. void main_attr(int attribute, int dim)                        /*;attribute*/
  34. {
  35.     switch(attribute) {
  36.  
  37.     case ATTR_ADDRESS:
  38.         POP_ADDR(bse, off);
  39.         create(2, &bas1, &off1, &ptr1);/* ADDRESS is a record */
  40.         *ADDR(bas1, off1) = bse;
  41.         *ADDR(bas1, off1 + 1) = off;
  42.         PUSH_ADDR(bas1, off1);
  43.         break;
  44.  
  45.     case ATTR_CALLABLE:
  46.         POP(value);    /* task object */
  47.         value = (is_callable(value));
  48.         PUSH(value);
  49.         break;
  50.  
  51.     case ATTR_COUNT:
  52.         POP(val2);        /* member in family */
  53.         POP(val1);        /* entry family */
  54.         value = count(val1, val2);
  55.         PUSH(value);
  56.         break;
  57.  
  58.     case ATTR_T_CONSTRAINED:
  59.         break;
  60.  
  61.     case ATTR_O_CONSTRAINED:
  62.         break;
  63.  
  64.     case ATTR_T_FIRST:
  65.     case ATTR_T_LAST:
  66.         POP_ADDR(bse, off);/* type */
  67.         ptr = ADDR(bse, off);
  68.         size = SIZE(ptr);
  69.         if (TYPE(ptr) == TT_FX_RANGE) {
  70.             if (attribute == ATTR_T_FIRST)
  71.                 PUSHL(FX_RANGE(ptr)->fxlow);
  72.             else
  73.                 PUSHL(FX_RANGE(ptr)->fxhigh);
  74.         }
  75.         else if (TYPE(ptr) == TT_FL_RANGE) {
  76.             if (attribute == ATTR_T_FIRST)
  77.                 PUSHF(FL_RANGE(ptr)->fllow);
  78.             else
  79.                 PUSHF(FL_RANGE(ptr)->flhigh);
  80.         }
  81.         else if ((TYPE(ptr) == TT_I_RANGE)
  82.           ||     (TYPE(ptr) == TT_E_RANGE)
  83.           ||     (TYPE(ptr) == TT_ENUM)) {
  84.             if (attribute == ATTR_T_FIRST)
  85.                 PUSH(I_RANGE(ptr)->ilow);
  86.             else
  87.                 PUSH(I_RANGE(ptr)->ihigh);
  88.         }
  89. #ifdef LONG_INT
  90.         else if (TYPE(ptr) == TT_L_RANGE) {
  91.             if (attribute == ATTR_T_FIRST)
  92.                 PUSHL(L_RANGE(ptr)->llow);
  93.             else
  94.                 PUSHL(L_RANGE(ptr)->lhigh);
  95.         }
  96. #endif
  97.         else    /* error */
  98.             raise(SYSTEM_ERROR,"Unknown type for attribute FIRST or LAST");
  99.         break;
  100.  
  101.     case ATTR_O_FIRST:
  102.     case ATTR_O_LAST:
  103.         POP_ADDR(bse, off);/* type */
  104.         ptr = ADDR(bse, off);
  105.         POP_ADDR(bas1, off1);/* to get rid of array */
  106.         val1 = *ptr;    /* type of type */
  107.         if (val1 == TT_S_ARRAY) {
  108.             if (attribute == ATTR_O_LAST)
  109.                 value = S_ARRAY(ptr)->sahigh;
  110.             else
  111.                 value = S_ARRAY(ptr)->salow;
  112.             PUSH(value);
  113.         }
  114.         else if (val1 == TT_C_ARRAY || val1 == TT_U_ARRAY) {
  115.             /* Beware: indices in reverse order */
  116.             ptr += 2 * (ARRAY(ptr)->dim - dim);
  117.             bse = ARRAY(ptr)->index1_base;
  118.             off = ARRAY(ptr)->index1_offset;
  119.             ptr = ADDR(bse, off);
  120.             if ((TYPE(ptr) == TT_I_RANGE)
  121.               ||(TYPE(ptr) == TT_E_RANGE)
  122.               ||(TYPE(ptr) == TT_ENUM)) {
  123.                 if (attribute == ATTR_O_LAST)
  124.                     PUSH(I_RANGE(ptr)->ihigh);
  125.                 else
  126.                     PUSH(I_RANGE(ptr)->ilow);
  127.             }
  128. #ifdef LONG_INT
  129.             else if (TYPE(ptr) == TT_L_RANGE) {
  130.                 if (attribute == ATTR_O_LAST)
  131.                     PUSHL(L_RANGE(ptr)->lhigh);
  132.                 else
  133.                     PUSHL(L_RANGE(ptr)->llow);
  134.             }
  135. #endif
  136.         }
  137.         else if (val1 == TT_D_ARRAY) {
  138.             bas1 = D_TYPE(ptr)->dbase;
  139.             off1 = D_TYPE(ptr)->doff;
  140.             ptr += WORDS_D_TYPE + 4 *(dim - 1);
  141.             if (attribute == ATTR_O_LAST)
  142.                 ptr += 2;
  143.             if (*ptr == 0)
  144.                 PUSH(*(ptr + 1));
  145.             else
  146.                 raise(SYSTEM_ERROR, "Attribute on discriminant bound");
  147.         }
  148.         break;
  149.  
  150.     case ATTR_T_LENGTH:
  151.         POP_ADDR(bse, off);
  152.         ptr = ADDR(bse, off);
  153.         size = SIZE(ptr);
  154.         if (size == 1) {
  155.             if (I_RANGE(ptr)->ihigh < I_RANGE(ptr)->ilow)
  156.                 value = 0; 
  157.             else
  158.                 value = I_RANGE(ptr)->ihigh - I_RANGE(ptr)->ilow + 1;
  159.             PUSH(value);
  160.         }
  161. #ifdef LONG_INT
  162.         else /* size=2 */ {
  163.             if (L_RANGE(ptr)->lhigh < L_RANGE(ptr)->llow)
  164.                 lvalue = 0; 
  165.             else
  166.                 lvalue = L_RANGE(ptr)->lhigh - L_RANGE(ptr)->llow;
  167.             PUSHL(lvalue);
  168.         }
  169. #endif
  170.         break;
  171.  
  172.     case ATTR_O_LENGTH:
  173.         POP_ADDR(bse, off);/* type */
  174.         ptr = ADDR(bse, off);
  175.         POP_ADDR(bas1, off1);/* to get rid of array */
  176.         val1 = TYPE(ptr);    /* type of type */
  177.         if (val1 == TT_S_ARRAY) {
  178.             /* the calculation of max is unuseful ! the substraction may
  179.              * produce an overflow and a positive result
  180.              */
  181.             if (S_ARRAY(ptr)->sahigh < S_ARRAY(ptr)->salow)
  182.                 value = 0; 
  183.             else {
  184.                 /*value=MAX(S_ARRAY(ptr)->sahigh-S_ARRAY(ptr)->salow + 1, 0);*/
  185.                 value = S_ARRAY(ptr)->sahigh - S_ARRAY(ptr)->salow + 1;
  186.             }
  187.             PUSH(value);
  188.         }
  189.         else if (val1 == TT_C_ARRAY) {
  190.             /* Beware: indices in reverse order */
  191.             ptr += 2 * (ARRAY(ptr)->dim - dim);
  192.             bse = ARRAY(ptr)->index1_base;
  193.             off = ARRAY(ptr)->index1_offset;
  194.             ptr = ADDR(bse, off);
  195.             /*  value = MAX(I_RANGE(ptr)->ihigh - I_RANGE(ptr)->ilow + 1, 0); */
  196.             if (I_RANGE(ptr)->ihigh < I_RANGE(ptr)->ilow)
  197.                 value = 0; 
  198.             else
  199.                 value = I_RANGE(ptr)->ihigh - I_RANGE(ptr)->ilow + 1;
  200.             PUSH(value);
  201.         }
  202.         break;
  203.  
  204.     case ATTR_T_RANGE:
  205.         POP_ADDR(bse, off);
  206.         ptr = ADDR(bse, off);
  207.         size = SIZE(ptr);
  208.         if (size == 1) {
  209.             PUSH(I_RANGE(ptr)->ilow);
  210.             PUSH(I_RANGE(ptr)->ihigh);
  211.         }
  212. #ifdef LONG_INT
  213.         else /* size == 2 */ {
  214.             lvalue = L_RANGE(ptr)->lhigh - L_RANGE(ptr)->llow;
  215.             PUSHL(lvalue);
  216.         }
  217. #endif
  218.         break;
  219.  
  220.     case ATTR_O_RANGE:
  221.         POP_ADDR(bse, off);/* type */
  222.         ptr = ADDR(bse, off);
  223.         POP_ADDR(bas1, off1);/* to get rid of array */
  224.         val1 = TYPE(ptr);    /* type of type */
  225.         if (val1 == TT_S_ARRAY) {
  226.             val_high = S_ARRAY(ptr)->sahigh;
  227.             val_low = S_ARRAY(ptr)->salow;
  228.             PUSH(val_low);
  229.             PUSH(val_high);
  230.         }
  231.         else if (val1 == TT_C_ARRAY) {
  232.             /*      Beware: indices in reverse order */
  233.             ptr += 2 * (ARRAY(ptr)->dim - dim);
  234.             bse = ARRAY(ptr)->index1_base;
  235.             off = ARRAY(ptr)->index1_offset;
  236.             ptr = ADDR(bse, off);
  237.             size = SIZE(ptr);
  238.             if (size == 1) {
  239.                 PUSH(I_RANGE(ptr)->ilow);
  240.                 PUSH(I_RANGE(ptr)->ihigh);
  241.             }
  242. #ifdef LONG_INT
  243.             else /*(size == 2)*/ {
  244.                 PUSHL(L_RANGE(ptr)->llow);
  245.                 PUSHL(L_RANGE(ptr)->lhigh);
  246.             }
  247. #endif
  248.         }
  249.         break;
  250.  
  251.     case ATTR_IMAGE:
  252.         image_attribute();
  253.         break;
  254.  
  255.     case ATTR_VALUE:
  256.         value_attribute();
  257.         break;
  258.  
  259.     case ATTR_PRED:
  260.         POP_ADDR(bse, off);/* type */
  261.         ptr = ADDR(bse, off);
  262.         if ((TYPE(ptr) == TT_I_RANGE)
  263.           ||(TYPE(ptr) == TT_E_RANGE)
  264.           ||(TYPE(ptr) == TT_ENUM)) {
  265.             POP(value);
  266.             if (value <= I_RANGE(ptr)->ilow)
  267.                 raise(CONSTRAINT_ERROR, "Out of range (PRED)");
  268.             value--;
  269.             PUSH(value);
  270.         }
  271. #ifdef LONG_INT
  272.         else if (TYPE(ptr) == TT_L_RANGE) {
  273.             POPL(lvalue);
  274.             if (lvalue <= L_RANGE(ptr)->llow)
  275.                 raise (CONSTRAINT_ERROR, "Out of range (PRED)");
  276.             lvalue--;
  277.             PUSHL(lvalue);
  278.         }
  279. #endif
  280.         else    /* error */
  281.             raise(SYSTEM_ERROR,"Unknown type for attribute PRED");
  282.         break;
  283.  
  284.     case ATTR_SUCC:
  285.         POP_ADDR(bse, off);/* type */
  286.         ptr = ADDR(bse, off);
  287.         if ((TYPE(ptr) == TT_I_RANGE)
  288.           ||(TYPE(ptr) == TT_E_RANGE)
  289.           ||(TYPE(ptr) == TT_ENUM)) {
  290.             POP(value);
  291.             if (value >= I_RANGE(ptr)->ihigh)
  292.                 raise(CONSTRAINT_ERROR, "Out of range (SUCC)");
  293.             value++;
  294.             PUSH(value);
  295.         }
  296. #ifdef LONG_INT
  297.         else if (TYPE(ptr) == TT_L_RANGE) {
  298.             POPL(lvalue);
  299.             if (lvalue >= L_RANGE(ptr)->lhigh)
  300.                 raise (CONSTRAINT_ERROR, "Out of range (SUCC)");
  301.             lvalue++;
  302.             PUSHL(lvalue);
  303.         }
  304. #endif
  305.         else    /* error */
  306.             raise(SYSTEM_ERROR,"Unknown type for attribute SUCC");
  307.         break;
  308.  
  309.     case ATTR_SIZE:
  310.         POP_ADDR(bse, off);
  311.         ptr1 = ADDR(bse, off);
  312.         value = SIZE(ptr1);
  313.         if ((TYPE(ptr1) == TT_RECORD     
  314.             || TYPE(ptr1) == TT_C_RECORD
  315.              || TYPE(ptr1) == TT_U_RECORD     
  316.             || TYPE(ptr1) == TT_V_RECORD)
  317.             && (U_RECORD(ptr1)->repr_size != 0)) {
  318.            PUSH(U_RECORD(ptr1)->repr_size);
  319.         }    
  320.         else if (TYPE(ptr1) == TT_ACCESS) {
  321.            PUSH(32);
  322.         }    
  323.         else {
  324.            PUSH(value * BITS_SU);
  325.         }
  326.         break;
  327.  
  328.     case ATTR_STORAGE_SIZE:
  329.         POP_ADDR(bse, off);
  330.         ptr1 = ADDR(bse, off);
  331.         if (TYPE(ptr1) == TT_ACCESS) {
  332.            value = ACCESS(ptr1)->collection_size;
  333.         }
  334.         else {
  335.             value = TASK(ptr1)->collection_size;
  336.         }
  337.         PUSH(value);
  338.         break;
  339.  
  340.     case ATTR_TERMINATED:
  341.         POP(value);    /* task object */
  342.         value = (is_terminated(value));
  343.         PUSH(value);
  344.         break;
  345.  
  346.     case ATTR_MANTISSA:
  347.     case ATTR_LARGE:
  348.         POP_ADDR(bse, off);/* type */
  349.         ptr = ADDR(bse, off);
  350.         if (TYPE(ptr) == TT_FX_RANGE) {
  351.             long power ;
  352.             fval1 = FX_RANGE(ptr)->fxlow;
  353.             fval2 = FX_RANGE(ptr)->fxhigh;
  354.             fval1 = MAX(fval1, fval2);
  355.             value = 1;
  356.             POP(ratio);    /* ratio between subtype's and base type's SMALL */
  357.             power = 1;
  358.             /* Compute value s.t. 2 ** value - 1 includes the upper bound -1.
  359.              * Given that the small of the subtype may be larger than that of
  360.              * the type, the 'last of the subtype may be -ratio- away from the
  361.              * given bound.
  362.              */
  363.             while (power * ratio < fval1 - ratio) {
  364.                 power = power + power + 1;
  365.                 value++;
  366.             }
  367.             if (attribute == ATTR_MANTISSA)
  368.                 PUSH(value);
  369.             else {        /* attribute = A_LARGE */
  370.                 lvalue = power * ratio ;
  371.                 PUSHL(lvalue) ;
  372.             }
  373.         }
  374.         else {        /* floating point */
  375.             /* TBSL */
  376.         }
  377.         break;
  378.  
  379.     case ATTR_FORE:
  380.         POP_ADDR(bse, off);/* type */
  381.         ptr = ADDR(bse, off);
  382.         POP(d);
  383.         POP(n);
  384.  
  385.         fval1 = FX_RANGE(ptr)->fxhigh;
  386.         fval2 = FX_RANGE(ptr)->fxlow;
  387.         fval1 = ABS(fval1);
  388.         fval2 = ABS(fval2);
  389.         n *= MAX(fval1, fval2);
  390.         value = 2;
  391.         while (n / d >= 10) {
  392.             d *= 10;
  393.             value++;
  394.         }
  395.         PUSH(value);
  396.         break;
  397.  
  398.     case ATTR_WIDTH:
  399.         POP_ADDR(bse, off);/* type */
  400.         ptr = ADDR(bse, off);
  401.         val1 = TYPE(ptr);    /* type of type */
  402.         val_low = I_RANGE(ptr)->ilow;
  403.         val_high = I_RANGE(ptr)->ihigh;
  404.         if (val1 == TT_I_RANGE) {
  405.             if (val_low > val_high)
  406.                 value = 0;
  407.             else {
  408.                 val1 = ABS(val_low);
  409.                 val2 = ABS(val_high);
  410.                 i = MAX(val1, val2);
  411.                 value = 2;
  412.                 while (i > 10) {
  413.                     value += 1;
  414.                     i = i / 10;
  415.                 }
  416.             }
  417.         }
  418.  
  419.         else {
  420.             if (val1 == TT_E_RANGE) {
  421.                 bse = E_RANGE(ptr)->ebase;/* Literals are */
  422.                 off = E_RANGE(ptr)->eoff;/* in base type */
  423.                 ptr = ADDR(bse, off);
  424.             }
  425.             ptr += WORDS_E_RANGE;/* skip litrals not in subtype */
  426.             for (i = 0; i <= val_low - 1; i++)
  427.                 ptr += *ptr + 1;
  428.             value = 0;
  429.             for (i = val_low; i <= val_high; i++) {
  430.                 if (*ptr > value)
  431.                     value = *ptr;
  432.                 ptr += *ptr + 1;
  433.             }
  434.         }
  435.         PUSH(value);
  436.         break;
  437.  
  438.     default:
  439.         raise(SYSTEM_ERROR, "Unknown attribute");
  440.     }
  441. }
  442.  
  443. void convert(int bse, int off)                                /*;convert*/
  444. {
  445.     int    *ptr_from, *ptr_to, *ptr4, exp2, exp5;
  446.     int     res_sign, exponent;
  447.     long    mul_fact, div_fact;
  448.     int     from_is_empty,to_is_empty;
  449.  
  450.     ptr_to = ADDR(bse, off);
  451.     POP_ADDR(bas1, off1);
  452.     ptr_from = ADDR(bas1, off1);
  453.  
  454.     /* Deal with combinations of from/to (other combinations handled by
  455.      * codegen) 
  456.      */
  457.     if (TYPE(ptr_to) == TT_I_RANGE) {
  458.         if (TYPE(ptr_from) == TT_FL_RANGE) {
  459.             POPF(rvalue);
  460.             if (ABS(rvalue) >(float)(MAX_LONG))
  461.                 raise(NUMERIC_ERROR, "Integer out of bounds");
  462.             else {
  463.                 value = (rvalue + (rvalue > 0.0? 0.5 : -0.5));
  464.                 PUSH(value);
  465.             }
  466.         }
  467.         /* If fixed range, is always integer_fixed ($FIXED) */
  468.         else if (TYPE(ptr_from) == TT_FX_RANGE) {
  469.             POPL(lvalue);
  470.             value = lvalue;
  471.             PUSH(value);
  472.             if ((long) value != lvalue)                    /* if overflow */
  473.                 raise(NUMERIC_ERROR, "fixed_point conversion");
  474.         }
  475.         /* Note: nothing to do if *ptr_from == TT_I_RANGE */
  476.     }
  477.  
  478.     else if (TYPE(ptr_to) == TT_FL_RANGE) {
  479.         if (TYPE(ptr_from) == TT_I_RANGE) {
  480.             POP(value);
  481.             rvalue = value;
  482.             PUSHF(rvalue);
  483.         }
  484.         else if (TYPE(ptr_from) == TT_FX_RANGE) {
  485.             POPL(lvalue);
  486.             ptr = ptr_from;
  487.             exp2 = FX_RANGE(ptr)->small_exp_2;
  488.             exp5 = FX_RANGE(ptr)->small_exp_5;
  489.             if (lvalue == 0)
  490.                 PUSHF(0.0);
  491.             else {
  492.                 res_sign = SIGN(lvalue);/* sign of result */
  493.                 mul_fact = ABS(lvalue);
  494.                 div_fact = 1;
  495.  
  496.                 if (exp5 < 0) {    /* take care of powers of 5 */
  497.                     for (i = exp5; i != 0; i++)
  498.                         div_fact *= 5;
  499.                 }
  500.                 else {
  501.                     for (i = exp5; i != 0; i--)
  502.                         mul_fact *= 5;
  503.                 }
  504.  
  505.                 /*      compute the division as if there were no problem */
  506.                 /*     (convert the two factors to floating points before) */
  507.  
  508.                 rvalue = FLOAT(mul_fact) / FLOAT(div_fact);
  509.                 /* expn returns the integer exponent of a positive float */
  510.                 exponent = expn(rvalue) - 21; /* float'mantissa = 21 */
  511.                 if (exponent < 0) { /* if not enough bits, get larger num */
  512.                     for (i = exponent; i != 0; i++)
  513.                         mul_fact *= 2;
  514.                 }
  515.                 else {
  516.                     for (i = exponent; i != 0; i--)
  517.                         div_fact *= 2;
  518.                 }
  519.                 exp2 += exponent; /* adjust the exponent */
  520.  
  521.                 lvalue = mul_fact / div_fact; /* compute result */
  522.                 if (lvalue <(1024L * 1024L)) { /* case of < 21 bits */
  523.                     mul_fact *= 2;
  524.                     exp2--;
  525.                 }
  526.                 else if (lvalue >(1024L * 2048L) - 1) { /* case of > 21 bits */
  527.                     div_fact *= 2;
  528.                     exp2++;
  529.                 }
  530.                 else {        /* 21 bits exactly */
  531.                 }
  532.                 /*      watch out: we introduced a bias in the exponent */
  533.                 if (exp2 >(84 - 21))
  534.                     raise(NUMERIC_ERROR, "Floating point value overflow");
  535.                 else if (exp2 <(-84 - 21))
  536.                     PUSHF(0.0);    /* underflow */
  537.                 else {
  538.                     rvalue = FLOAT(res_sign *(mul_fact / div_fact));
  539.                     if (exp2 < 0) {
  540.                         for (i = exp2; i != 0; i++)
  541.                             rvalue /= 2.0;
  542.                     }
  543.                     else {
  544.                         for (i = exp2; i != 0; i--)
  545.                             rvalue *= 2.0;
  546.                     }
  547.                     PUSHF(rvalue);
  548.                 }
  549.             }
  550.         }
  551.         /* Note: nothing to do in TYPE(ptr_from) == TT_FL_RANGE case */
  552.     }
  553.  
  554.     else if (TYPE(ptr_to) == TT_FX_RANGE) {
  555.         if (TYPE(ptr_from) == TT_I_RANGE) {
  556.             POP(value); /* target type is integer_fixed */
  557.             lvalue = (long) value;
  558.             PUSHL(lvalue);
  559.         }
  560.         else if (TYPE(ptr_from) == TT_FL_RANGE) {
  561.             POPF(rvalue);
  562.             if (rvalue == 0.0)
  563.                 PUSHL(0);
  564.             else {
  565.                 res_sign = SIGN(rvalue);
  566.                 rvalue = ABS(rvalue);
  567.                 exp2 = expn(rvalue) - 21;
  568.                 if (exp2 < 0) {
  569.                     for (i = exp2; i != 0; i++)
  570.                         rvalue *= 2.0;
  571.                 }
  572.                 else {
  573.                     for (i = exp2; i != 0; i--)
  574.                         rvalue /= 2.0;
  575.                 }
  576.                 mul_fact = rvalue;    /* exactly 21 bits */
  577.                 div_fact = 1;
  578.                 exp2 = FX_RANGE(ptr_to)->small_exp_2 - exp2;
  579.                 exp5 = FX_RANGE(ptr_to)->small_exp_5;
  580.                 if (exp5 < 0) {    /* at most 42 bits */
  581.                     for (i = exp5; i != 0; i++)
  582.                         mul_fact *= 5;
  583.                 }
  584.                 else {
  585.                     for (i = exp5; i != 0; i--)
  586.                         div_fact *= 5;
  587.                 }
  588.                 if (exp2 < 0) {
  589.                     for (i = exp2; i != 0; i++)
  590.                         mul_fact *= 2;
  591.                 }
  592.                 /* delay div by powers of two to avoid overflows om div_fact */
  593.                 lvalue = mul_fact / div_fact;
  594.                 if (exp2 > 0) {
  595.                     for (i = exp2; i != 0; i--)
  596.                         lvalue /= 2;
  597.                 }
  598.                 lvalue *= res_sign;
  599.                 if (lvalue < MIN_LONG || lvalue > MAX_LONG) {
  600.                     raise (NUMERIC_ERROR, "Fixed point overflow");
  601.                     lvalue = 0;
  602.                 }
  603.             }
  604.             PUSHL(lvalue);
  605.         }
  606.  
  607.         else if (TYPE(ptr_from) == TT_FX_RANGE) {
  608.             POPL(lvalue);
  609.             res_sign = SIGN(lvalue);
  610.             lvalue = ABS(lvalue);
  611.             int_tom(fix_val1,lvalue);
  612.             fix_convert(fix_val1, FX_RANGE(ptr_from), FX_RANGE(ptr_to));
  613.             lvalue = int_tol(fix_val1);
  614.             if(arith_overflow)
  615.                 raise(NUMERIC_ERROR,"Fixed point conversion overflow");
  616.             PUSHL(res_sign*lvalue);
  617.         }
  618.         else
  619.             raise(SYSTEM_ERROR,"Conversion from an unknown type");
  620.     }
  621.     else if (TYPE(ptr_to) == TT_U_ARRAY || TYPE(ptr_to) == TT_C_ARRAY) {
  622.         if (TYPE(ptr_from) == TT_U_ARRAY || TYPE(ptr_from) == TT_C_ARRAY) {
  623.             nb_dim = ARRAY(ptr_to)->dim;
  624.             ptr3 = &(ARRAY(ptr_from)->index1_base);
  625.             ptr4 = &(ARRAY(ptr_to)->index1_base);
  626.             from_is_empty = FALSE;
  627.             to_is_empty = FALSE;
  628.             for (i = 1; i <= nb_dim; i++) {
  629.                 bas1 = *ptr3++;
  630.                 off1 = *ptr3++;
  631.                 ptr1 = ADDR(bas1, off1);
  632.                 bas2 = *ptr4++;
  633.                 off2 = *ptr4++;
  634.                 ptr2 = ADDR(bas2, off2);
  635.                 if (I_RANGE(ptr1)->ilow > I_RANGE(ptr1)->ihigh)
  636.                     from_is_empty = TRUE;
  637.                 if (I_RANGE(ptr2)->ilow > I_RANGE(ptr2)->ihigh)
  638.                     to_is_empty = TRUE;
  639.             }
  640.             if (from_is_empty && to_is_empty) {
  641.                 /* both are empty arrays: do not convert */
  642.                 PUSH_ADDR(bse,off);
  643.                 return;
  644.             }
  645.             if (from_is_empty || to_is_empty) {
  646.                 /* one is empty, the other is not */
  647.                 raise(CONSTRAINT_ERROR, "Array conversion");
  648.                 return;
  649.             }
  650.  
  651.             /* both have components: do the conversion */
  652.             ptr_from = &(ARRAY(ptr_from)->index1_base);
  653.             ptr_to = &(ARRAY(ptr_to)->index1_base);
  654.             for (i = 1; i <= nb_dim; i++) {
  655.                 bas1 = *ptr_from++;
  656.                 off1 = *ptr_from++;
  657.                 ptr1 = ADDR(bas1, off1);
  658.                 bas2 = *ptr_to++;
  659.                 off2 = *ptr_to++;
  660.                 ptr2 = ADDR(bas2, off2);
  661.                 if (I_RANGE(ptr1)->ihigh - I_RANGE(ptr1)->ilow
  662.                   !=I_RANGE(ptr2)->ihigh - I_RANGE(ptr2)->ilow) {
  663.                     raise(CONSTRAINT_ERROR, "Array conversion");
  664.                     return;
  665.                 }
  666.             }
  667.         }
  668.         else if (TYPE(ptr_from) == TT_S_ARRAY) {
  669.             bas2 = ARRAY(ptr_to)->index1_base;
  670.             off2 = ARRAY(ptr_to)->index1_offset;
  671.             ptr2 = ADDR(bas2, off2);
  672.             from_is_empty =
  673.               (S_ARRAY(ptr_from)->salow > S_ARRAY(ptr_from)->sahigh);
  674.             to_is_empty = (I_RANGE(ptr2)->ilow > I_RANGE(ptr2)->ihigh);
  675.             if (from_is_empty && to_is_empty) {
  676.                 /* both are empty arrays: do not convert */
  677.                 PUSH_ADDR(bse,off);
  678.                 return;
  679.             }
  680.             if (from_is_empty || to_is_empty) {
  681.                 /* one is empty, the other is not */
  682.                 raise(CONSTRAINT_ERROR, "Array conversion");
  683.                 return;
  684.             }
  685.             /* both have components: do the conversion */
  686.             if (S_ARRAY(ptr_from)->sahigh - S_ARRAY(ptr_from)->salow !=
  687.                 I_RANGE(ptr2)->ihigh - I_RANGE(ptr2)->ilow) {
  688.                 raise(CONSTRAINT_ERROR, "Array conversion");
  689.                 return;
  690.             }
  691.         }
  692.         PUSH_ADDR(bse,off);
  693.     }
  694.     else if (TYPE(ptr_to) == TT_S_ARRAY) {
  695.         if (TYPE(ptr_from) == TT_U_ARRAY || TYPE(ptr_from) == TT_C_ARRAY) {
  696.             bas1 = ARRAY(ptr_from)->index1_base;
  697.             off1 = ARRAY(ptr_from)->index1_offset;
  698.             ptr1 = ADDR(bas1, off1);
  699.             from_is_empty = (I_RANGE(ptr1)->ilow > I_RANGE(ptr1)->ihigh);
  700.             to_is_empty = (S_ARRAY(ptr_to)->salow > S_ARRAY(ptr_to)->sahigh);
  701.             if (from_is_empty && to_is_empty) {
  702.                 /* both are empty arrays: do not convert */
  703.                 PUSH_ADDR(bse,off);
  704.                 return;
  705.             }
  706.             if (from_is_empty || to_is_empty) {
  707.                 /* one is empty, the other is not */
  708.                 raise(CONSTRAINT_ERROR, "Array conversion");
  709.                 return;
  710.             }
  711.             /* both have components: do the conversion */
  712.             if (I_RANGE(ptr1)->ihigh - I_RANGE(ptr1)->ilow !=
  713.                 S_ARRAY(ptr_to)->sahigh - S_ARRAY(ptr_to)->salow) {
  714.                 raise(CONSTRAINT_ERROR, "Array conversion");
  715.                 return;
  716.             }
  717.         }
  718.         else if (TYPE(ptr_from) == TT_S_ARRAY) {
  719.             from_is_empty =
  720.               (S_ARRAY(ptr_from)->salow > S_ARRAY(ptr_from)->sahigh);
  721.             to_is_empty = (S_ARRAY(ptr_to)->salow > S_ARRAY(ptr_to)->sahigh);
  722.             if (from_is_empty && to_is_empty) {
  723.                 /* both are empty arrays: do not convert */
  724.                 PUSH_ADDR(bse,off);
  725.                 return;
  726.             }
  727.             if (from_is_empty || to_is_empty) {
  728.                 /* one is empty, the other is not */
  729.                 raise(CONSTRAINT_ERROR, "Array conversion");
  730.                 return;
  731.             }
  732.             /* both have components: do the conversion */
  733.             if (S_ARRAY(ptr_from)->sahigh - S_ARRAY(ptr_from)->salow !=
  734.                 S_ARRAY(ptr_to)->sahigh - S_ARRAY(ptr_to)->salow) {
  735.                 raise(CONSTRAINT_ERROR, "Array conversion");
  736.                 return;
  737.             }
  738.         }
  739.         PUSH_ADDR(bse,off);
  740.     }
  741. }
  742.  
  743. /* TYPE_ELABORATE */
  744.  
  745. void type_elaborate(int flag, int bse, int off)            /*;type_elaborate*/
  746. {
  747.     /*
  748.      *  flag = 0 == type template is to remain global and the original
  749.      *        can be updated on the spot
  750.      *  flag = 1 == a new local type template has to be created
  751.      *
  752.      *  In the local case, the size of the object to allocate is computed, the
  753.      *  new type is created and initialized with the old one. From then on,
  754.      *  both cases, local and global, can proceed with the same code, given a
  755.      *  ptr in memory to the beginning of the type template.
  756.      */
  757.  
  758.     int    template_size, nb_field, variant_size, component_size, nb_fixed,
  759.     templ_bse, templ_off, temporary, last_offset, first_case,
  760.     *case_table_ptr, *field_table_ptr, offset, lbd, ubd, lng;
  761.     float  fval_high,fval_low;
  762.     long   fix_val_high,fix_val_low;
  763.  
  764.     /*GET_GAD(bse,off); bse,off retrieved by main_loop */
  765.     ptr = ADDR(bse,off);
  766.  
  767.     value = TYPE(ptr);      /*  type of type */
  768.     if (flag == 1) {
  769.         switch (value) {
  770.  
  771.         case TT_I_RANGE:
  772.             template_size = WORDS_I_RANGE;
  773.             break;
  774.  
  775.         case TT_FL_RANGE:
  776.             template_size = WORDS_FL_RANGE;
  777.             break;
  778.  
  779.         case TT_E_RANGE:
  780.             template_size = WORDS_E_RANGE;
  781.             break;
  782.  
  783.         case TT_FX_RANGE:
  784.             template_size = WORDS_FX_RANGE;
  785.             break;
  786.  
  787.         case TT_ACCESS:
  788.             template_size = WORDS_ACCESS;
  789.             break;
  790.  
  791.         case TT_RECORD:
  792.             nb_field = RECORD(ptr)->nb_field;
  793.             template_size = 3 * nb_field + WORDS_RECORD;
  794.             break;
  795.  
  796.         case TT_U_RECORD:
  797.         case TT_V_RECORD:
  798.             nb_field      = U_RECORD(ptr)->nb_field_u;
  799.             variant_size  = U_RECORD(ptr)->variant;
  800.             template_size = 3 * nb_field + WORDS_U_RECORD + variant_size;
  801.             break;
  802.  
  803.         case TT_C_RECORD:
  804.             nb_discr      = C_RECORD(ptr)->nb_discr_c;
  805.             template_size = WORDS_C_RECORD + nb_discr;
  806.             break;
  807.  
  808.         case TT_U_ARRAY:
  809.         case TT_C_ARRAY:
  810.             nb_dim           = ARRAY(ptr)->dim;
  811.             template_size = 2 * (nb_dim - 1) + WORDS_ARRAY;
  812.             break;
  813.  
  814.         case TT_D_RECORD:
  815.             nb_discr      = D_TYPE(ptr)->nb_discr_d;
  816.             template_size = WORDS_D_TYPE + 2 * nb_discr;
  817.             break;
  818.  
  819.         case TT_D_ARRAY:
  820.             nb_discr      = D_TYPE(ptr)->nb_discr_d;
  821.             template_size = WORDS_D_TYPE + 4 * nb_discr;
  822.             break;
  823.  
  824.         case TT_S_ARRAY:
  825.             template_size = WORDS_S_ARRAY;
  826.             break;
  827.  
  828.         case TT_TASK:
  829.             template_size = WORDS_TASK + (TASK(ptr)->nb_families * 2);
  830.             break;
  831.  
  832.         default:
  833.             ;
  834.         }
  835.  
  836.         ptr1 = ptr;
  837.         create (template_size, &templ_bse, &templ_off, &ptr);
  838.  
  839.         for (i = 0; i < template_size; i++)
  840.             *ptr++ = *ptr1++;
  841.  
  842.         ptr -= template_size;           /* restore ptr */
  843.     }
  844.  
  845.     /* Now ptr designates the template to modify */
  846.  
  847.     switch (value) {
  848.  
  849.     case TT_E_RANGE:
  850.         POP(val_high);
  851.         E_RANGE(ptr)->ehigh = val_high;
  852.         POP(val_low);
  853.         E_RANGE(ptr)->elow = val_low;
  854.         break;
  855.  
  856.     case TT_FL_RANGE:
  857.         POPF(fval_high);
  858.         FL_RANGE(ptr)->flhigh = fval_high;
  859.         POPF(fval_low);
  860.         FL_RANGE(ptr)->fllow = fval_low;
  861.         break;
  862.  
  863.     case TT_I_RANGE:
  864.         POP(val_high);
  865.         I_RANGE(ptr)->ihigh = val_high;
  866.         POP(val_low);
  867.         I_RANGE(ptr)->ilow = val_low;
  868.         break;
  869.  
  870.     case TT_FX_RANGE:
  871.         POPL(fix_val_high);
  872.         POPL(fix_val_low);
  873.         FX_RANGE(ptr)->fxlow = fix_val_low;
  874.         FX_RANGE(ptr)->fxhigh = fix_val_high;
  875.         break;
  876.  
  877.     case TT_ACCESS:
  878.         ACCESS(ptr)->master_task = tp;
  879.         ACCESS(ptr)->master_bfp = bfp;
  880.         break;
  881.  
  882.     case TT_S_ARRAY:
  883.         break;
  884.  
  885.     case TT_U_ARRAY:
  886.         nb_dim = ARRAY(ptr)->dim;
  887.         update_address(ptr1 = &(ARRAY(ptr)->component_base));
  888.         for (i = 0; i < nb_dim; i++) {
  889.             ptr1 += 2;
  890.             update_address(ptr1);
  891.         }
  892.         break;
  893.  
  894.     case TT_C_ARRAY:
  895.         nb_dim = ARRAY(ptr)->dim;
  896.         update_address(ptr1 = &(ARRAY(ptr)->component_base));
  897.         component_size = SIZE(ADDR(*ptr1, *(ptr1 + 1)));
  898.         for (i = 0; i < nb_dim; i++) {
  899.             ptr1 += 2;
  900.             update_address(ptr1);
  901.             val_high = I_RANGE(ADDR(*ptr1, *(ptr1 + 1)))->ihigh;
  902.             val_low  = I_RANGE(ADDR(*ptr1, *(ptr1 + 1)))->ilow;
  903.             if(val_low > val_high) component_size = 0;
  904.             if (component_size) {
  905.                 temporary = word_sub(val_high,val_low,&overflow);
  906.                 if (overflow) break;
  907.                 temporary = word_add(temporary,1,&overflow);
  908.                 if (overflow) break;
  909.                 temporary = MAX(0,temporary);
  910.                 component_size = word_mul(component_size,temporary,&overflow);
  911.                 if (overflow) break;
  912.             }
  913.         }
  914.         if (overflow)
  915.             raise(NUMERIC_ERROR,"Type size overflow");
  916.         I_RANGE(ptr)->object_size = component_size;
  917.         break;
  918.  
  919.     case TT_D_ARRAY:
  920.         update_address(&(D_TYPE(ptr)->dbase));
  921.         nb_discr = D_TYPE(ptr)->nb_discr_d;
  922.         ptr2 = ptr + WORDS_D_TYPE + 4 * nb_discr - 1;
  923.         for (i = 0; i < 2 * nb_discr; i++) {
  924.             POP(value);
  925.             *ptr2 = value;
  926.             ptr2 -= 2;
  927.         }
  928.         break;
  929.  
  930.     case TT_RECORD:
  931.         nb_field = RECORD(ptr)->nb_field;
  932.         last_offset =
  933.           compute_offset(0,nb_field-1,0,-1, ptr + WORDS_RECORD, 0);
  934.         SIZE(ptr) = last_offset;
  935.         break;
  936.  
  937.     case TT_U_RECORD:
  938.         nb_field = U_RECORD(ptr)->nb_field_u;
  939.         nb_fixed = U_RECORD(ptr)->nb_fixed_u;
  940.         first_case = U_RECORD(ptr)->first_case;
  941.         field_table_ptr = ptr + WORDS_U_RECORD;
  942.         case_table_ptr = field_table_ptr + 3 * nb_field;
  943.         last_offset = compute_offset(
  944.           0,              /*  first field of fixed part */
  945.           nb_fixed-1,     /*  last field of fixed part */
  946.           0,              /*  offset of first field */
  947.           first_case,
  948.           field_table_ptr,
  949.           case_table_ptr);
  950.         SIZE(ptr) = last_offset;
  951.         break;
  952.  
  953.     case TT_V_RECORD:
  954.         nb_field = U_RECORD(ptr)->nb_field_u;
  955.         nb_fixed = U_RECORD(ptr)->nb_fixed_u;
  956.         first_case = U_RECORD(ptr)->first_case;
  957.         field_table_ptr = ptr + WORDS_U_RECORD + 1;
  958.         for (i = 1; i <= nb_field; i++) {
  959.             update_address(field_table_ptr);
  960.             field_table_ptr += 3;
  961.         }
  962.         break;
  963.  
  964.     case TT_C_RECORD:
  965.         update_address (&(C_RECORD(ptr)->cbase));
  966.         ptr2 = ADDR (C_RECORD(ptr)->cbase, C_RECORD(ptr)->coff); /* base type */
  967.         nb_discr = C_RECORD(ptr)->nb_discr_c;
  968.         ptr1 = ptr + WORDS_C_RECORD;
  969.         for (i = 0; i < nb_discr; i++) {
  970.             POP(value);
  971.             *ptr1++ = value;
  972.             discr_list[i] = value;
  973.         }
  974.         if (TYPE(ptr2) == TT_U_RECORD)
  975.             SIZE(ptr) = SIZE(ptr2);
  976.         else if (TYPE(ptr2) == TT_V_RECORD) {
  977.             /* Here compute size of the subtype */
  978.             SIZE(ptr) = actual_size (ptr2,discr_list);
  979.         }
  980.         break;
  981.  
  982.     case TT_D_RECORD:
  983.         update_address (&(D_TYPE(ptr)->dbase));
  984.         nb_discr = D_TYPE(ptr)->nb_discr_d;
  985.         ptr2 = ptr + WORDS_D_TYPE + 2 * nb_discr - 1;
  986.         for (i = 1; i <= nb_discr; i++) {
  987.             POP(value);
  988.             *ptr2 = value;
  989.             ptr2 -= 2;
  990.         }
  991.         break;
  992.  
  993.     case TT_TASK:
  994.         update_address (&(TASK(ptr)->body_base));
  995.         ptr1   = ptr + WORDS_TASK;
  996.         offset = 0;
  997.         for (i = 1; i <= TASK(ptr)->nb_families; i++) {
  998.             bse = *ptr1;
  999.             off = *(ptr1 + 1);
  1000.             if (bse == 0 && off == 0) {         /* Simple entry */
  1001.                 *ptr1++ = offset;
  1002.                 *ptr1++ = 1;
  1003.                 offset += 1;
  1004.             }
  1005.             else {
  1006.                 if (bse == 0) {             /* Index subtype is local */
  1007.                     bse = STACK_FRAME(off);
  1008.                     off = STACK_FRAME(off+1);
  1009.                 }
  1010.                 lbd = I_RANGE(ADDR(bse, off))->ilow;
  1011.                 ubd = I_RANGE(ADDR(bse, off))->ihigh;
  1012.                 lng = ubd - lbd +1;
  1013.                 *ptr1++ = offset - lbd;
  1014.                 *ptr1++ = lng;
  1015.                 offset += lng;
  1016.             }
  1017.         }
  1018.         TASK(ptr)->nb_entries = offset;
  1019.         break;
  1020.  
  1021.  
  1022.     default:
  1023.         raise (SYSTEM_ERROR, "Elaborate unknown type");
  1024.     }
  1025.  
  1026.     if (flag == 1)
  1027.         PUSH_ADDR(templ_bse,templ_off);
  1028. }
  1029.  
  1030. void subprogram(int bse, int off)                         /*;subprogram*/
  1031. {
  1032.     ptr = ADDR(bse, off);
  1033.     if (*ptr < 0)
  1034.         *ptr = -*ptr;        /* mark the procedure as elab. */
  1035.  
  1036.     /* copy relay table */
  1037.  
  1038.     POP_ADDR(bas1, off1);    /* subprogram template */
  1039.     ptr1 = ADDR(bas1, off1);
  1040.     if ((slot = SUBPROG(ptr1)->relay_slot) != 0) {
  1041.         ptr1 = ADDR(1, *ADDR(1,0));
  1042.         while (*ptr1 != slot)
  1043.             ptr1 += *(ptr1 + 1) + 2;
  1044.         ptr1 += 2;
  1045.     }
  1046.     else
  1047.         ptr1 += WORDS_SUBPROG;
  1048.  
  1049.     value = SIZE(ptr);        /* # of relayed objects */
  1050.     ptr += 2;
  1051.     for (i = 1; i <= value; i++) {
  1052.         sp = sfp + *ptr1++;
  1053.         *ptr++ = cur_stack[sp];
  1054.         *ptr++ = cur_stack[sp + 1];
  1055.     }
  1056. }
  1057.  
  1058. int compute_offset(int from_field, int to_field, int  field_offset,
  1059.   int next_case, int *field_table_ptr, int * case_table_ptr) /*;compute_offset*/
  1060. {
  1061.     int     i, *field_ptr, type_base, type_off, *type_ptr, *case_ptr,
  1062.       max_field_offset, nb_choices,last_offset;
  1063.  
  1064.     field_ptr = field_table_ptr + 3 * from_field;
  1065.     for (i = from_field; i <= to_field; i++) {
  1066.         *field_ptr = field_offset;
  1067.         update_address(field_ptr += 1);
  1068.         type_base = *field_ptr;
  1069.         type_off = *++field_ptr;
  1070.         type_ptr = ADDR(type_base, type_off);
  1071.         field_offset += SIZE(type_ptr);
  1072.         field_ptr++;
  1073.     }
  1074.  
  1075.     max_field_offset = field_offset;
  1076.     if (next_case != -1) {
  1077.         case_ptr = case_table_ptr + next_case + 1;
  1078.         nb_choices = *case_ptr;
  1079.  
  1080.         for (i = 1; i <= nb_choices; i++) {
  1081.             from_field = *++case_ptr;
  1082.             to_field = *++case_ptr;
  1083.             next_case = *++case_ptr;
  1084.             last_offset = compute_offset(
  1085.                 from_field, to_field,
  1086.                 field_offset,
  1087.                 next_case,
  1088.                 field_table_ptr,
  1089.                 case_table_ptr);
  1090.             if (last_offset > max_field_offset)
  1091.                 max_field_offset = last_offset;
  1092.             case_ptr++;
  1093.         }
  1094.     }
  1095.     return max_field_offset;
  1096. }
  1097.  
  1098. static void update_address(int *addr_ptr)                    /*;update_address*/
  1099. {
  1100.     int     type_base, type_off;
  1101.  
  1102.     type_base = *addr_ptr;
  1103.     if (type_base == 0) {    /* local address */
  1104.         type_off = *(addr_ptr + 1);
  1105.         type_base = STACK_FRAME(type_off);
  1106.         type_off = STACK_FRAME(type_off + 1);
  1107.         *addr_ptr = type_base;
  1108.         *(addr_ptr + 1) = type_off;
  1109.     }
  1110. }
  1111.  
  1112. void raise(int exception_value, char *reason)                    /*;raise*/
  1113. {
  1114.     if (exception_trace && cs > 2) {
  1115.         printf("raising exception %s in %s",
  1116.           exception_slots[exception_value],code_slots[cs]);
  1117.         if(lin>0)
  1118.             printf(" at line %d",lin);
  1119.         if(*reason != '\0')
  1120.             printf(" (%s)\n",reason);
  1121.         else
  1122.             printf("\n");
  1123.     }
  1124.     if(*reason != '\0') {
  1125.         raise_cs = cs;
  1126.         raise_lin = lin;
  1127.         raise_reason = reason;
  1128.     }
  1129.     exr = exception_value;
  1130.     terminate_unactivated();
  1131.     ip = BLOCK_FRAME->bf_handler;
  1132.     BLOCK_FRAME->bf_handler = 0;
  1133. }
  1134.  
  1135. static void image_attribute()                            /*;image_attribute*/
  1136. {
  1137.     char    s[MAX_IDLEN];    /* chars and length of string */
  1138.     int     slen;        /* length of string */
  1139.     long    lv;
  1140.  
  1141.     POP_ADDR(bse, off);    /* type */
  1142.     ptr = ADDR(bse, off);
  1143.     val1 = TYPE(ptr);
  1144.  
  1145.     if (val1 == TT_E_RANGE) {    /* take base type */
  1146.         bse = E_RANGE(ptr)->ebase;
  1147.         off = E_RANGE(ptr)->eoff;
  1148.         ptr = ADDR(bse, off);
  1149.         val1 = TYPE(ptr);
  1150.     }
  1151.  
  1152.     if (val1 == TT_ENUM) {
  1153.         POP(value);
  1154.         ptr += WORDS_E_RANGE;
  1155.         if(*ptr == -1) { /* special case for CHARACTER */
  1156.             slen = 3;
  1157.             s[0] = s[2] = 39; /* prime character */
  1158.             s[1] = value;
  1159.         }
  1160.         else {
  1161.             for (i = 1; i <= value; i++)
  1162.                 ptr = ptr + *ptr + 1;
  1163.  
  1164.             slen = *ptr++;
  1165.             for (i = 0; i < slen; i++)
  1166.                 s[i] = *ptr++;
  1167.         }
  1168.     }
  1169.     else {
  1170.         if (val1 == TT_I_RANGE) {
  1171.             POP(value);
  1172.             lvalue = value;
  1173.         }
  1174. #ifdef LONG_INT
  1175.         else             /* val1 = TT_L_RANGE */
  1176.             POPL(lvalue);
  1177. #endif
  1178.         lv = ABS(value);
  1179.         i = MAX_IDLEN-1;
  1180.         if (lv == 0)
  1181.             s[i--] = '0';
  1182.         while (lv != 0) {
  1183.             s[i--] = (lv % 10) + '0';
  1184.             lv = lv / 10;
  1185.         }
  1186.         if (lvalue < 0)
  1187.             s[i] = '-';
  1188.         else
  1189.             s[i] = ' ';
  1190.         slen = 0;
  1191.         while (i < MAX_IDLEN)
  1192.             s[slen++] = s[i++];
  1193.     }
  1194.  
  1195.     create(slen, &bas1, &off1, &ptr1);
  1196.     for (i = 0; i < slen; i++)
  1197.         *ptr1++ = s[i];
  1198.     PUSH_ADDR(bas1, off1);
  1199.     create(WORDS_S_ARRAY, &bas2, &off2, &ptr2);
  1200.     S_ARRAY(ptr2)->ttype = TT_S_ARRAY;
  1201.     S_ARRAY(ptr2)->object_size = slen;
  1202.     S_ARRAY(ptr2)->index_size = 1;
  1203.     S_ARRAY(ptr2)->component_size = 1;
  1204.     S_ARRAY(ptr2)->salow = 1;
  1205.     S_ARRAY(ptr2)->sahigh = slen;
  1206.     PUSH_ADDR(bas2, off2);
  1207. }
  1208.  
  1209. static void value_attribute()                            /*;value_attribute*/
  1210. {
  1211.     int    *s;            /* pointer to string chars */
  1212.     int     slen;        /* length of string */
  1213.     int    i;            /* string index */
  1214.  
  1215.     POP_ADDR(bse, off);    /* type */
  1216.     ptr = ADDR(bse, off);
  1217.     POP_ADDR(bas1, off1);    /* string template */
  1218.     ptr1 = ADDR(bas1, off1);
  1219.     POP_ADDR(bas2, off2);    /* string value */
  1220.     s = ADDR(bas2, off2);
  1221.     slen = SIZE(ptr1);
  1222.     if (slen) {         /* point to end */
  1223.         s += slen; 
  1224.         s--;
  1225.     }
  1226.     while (slen > 0 && *s == ' ') {
  1227.         s--;  
  1228.         slen--;        /* get rid of the trailing blanks */
  1229.     }
  1230.     s = ADDR(bas2, off2);
  1231.     while (slen > 0 && *s == ' ') {
  1232.         s++;  
  1233.         slen--;        /* get rid of the leading blanks */
  1234.     }
  1235.     i = 0;
  1236.     while (i < slen)        /* convert to C string */
  1237.         work_string[i++] = (char)*s++;
  1238.     work_string[i] = '\0';
  1239.  
  1240.     if (setjmp(raise_env)) {
  1241.         data_exception = DATA_ERROR;
  1242.         return;
  1243.     }
  1244.     data_exception = CONSTRAINT_ERROR;
  1245.  
  1246.     val1 = TYPE(ptr);
  1247.     if (val1 == TT_ENUM || val1 == TT_E_RANGE)
  1248.         value = enum_ord(ptr, slen, CONSTRAINT_ERROR);
  1249.  
  1250.     else if (val1 == TT_I_RANGE
  1251. #ifdef LONG_INT
  1252.         || val1==TT_L_RANGE
  1253. #endif
  1254.         ) { /* second argument is dummy */
  1255.         lvalue = scan_integer_string(ptr,&i);
  1256.         if ((i+1) != slen)            /* If not all scanned */
  1257.             raise(CONSTRAINT_ERROR, "Number not integer literal for VALUE");
  1258.     }
  1259.     if (val1 == TT_I_RANGE) {
  1260.         value = (int) lvalue;
  1261.         if (value == lvalue)
  1262.             PUSH(value);
  1263.         else
  1264.             raise(CONSTRAINT_ERROR, "Number out of range for VALUE");
  1265.     }
  1266.     else
  1267.         PUSH(value);
  1268. }
  1269.  
  1270. void create_structure()                                    /*;create_structure*/
  1271. {
  1272.  
  1273.     POP_ADDR(bse, off);
  1274.     ptr = ADDR(bse, off);
  1275.     val1 = TYPE(ptr);
  1276.     val2 = SIZE(ptr);
  1277.  
  1278.     switch(val1) {
  1279.  
  1280.     case TT_U_ARRAY:
  1281.     case TT_C_ARRAY:
  1282.     case TT_S_ARRAY:
  1283.     case TT_D_ARRAY:
  1284.         create(val2, &bas1, &off1, &ptr1);
  1285.         PUSH_ADDR(bas1, off1);
  1286.         PUSH_ADDR(bse, off);            /* push type template */
  1287.         break;
  1288.  
  1289.     case TT_RECORD:
  1290.         create(val2, &bas1, &off1, &ptr1);
  1291.         PUSH_ADDR(bas1, off1);
  1292.         break;
  1293.  
  1294.     case TT_U_RECORD:
  1295.     case TT_V_RECORD:
  1296.         create(val2, &bas1, &off1, &ptr1);
  1297.         PUSH_ADDR(bas1, off1);
  1298.         *ptr1 = 0;        /* unconstrained */
  1299.         /* initialize the full record for the shake of comparisons.
  1300.          * note that the value used does not matter but has to be
  1301.          * the same in the code generator. If zero is used, 
  1302.          * the constraint bit might be included in that loop.
  1303.          */
  1304.         for (i = 1; i < val2; i++)
  1305.             *(ptr1 + i) = 0;
  1306.         break;
  1307.  
  1308.     case TT_C_RECORD:
  1309.         create(val2, &bas1, &off1, &ptr1);
  1310.         PUSH_ADDR(bas1, off1);
  1311.         *ptr1 = 1;        /* constrained */
  1312.         nb_discr = C_RECORD(ptr)->nb_discr_c;
  1313.  
  1314.         for (i = 1; i <= nb_discr; i++)
  1315.             *(ptr1 + i) = *(ptr + WORDS_C_RECORD  + i);
  1316.         break;
  1317.  
  1318.     case TT_D_RECORD:       /* to be checked */
  1319.         create(val2, &bas1, &off1, &ptr1);
  1320.         PUSH_ADDR(bas1, off1);
  1321.         *ptr1++ = 1;    /* constrained */
  1322.         nb_discr = C_RECORD(ptr)->nb_discr_c;
  1323.  
  1324.         for (i = 1; i <= nb_discr; i++)
  1325.             *ptr1++ = *(ptr++ + WORDS_C_RECORD + i);
  1326.         break;
  1327.  
  1328.     case TT_SUBPROG:
  1329.         if ((slot = SUBPROG(ptr)->relay_slot) != 0) {
  1330.             ptr2 = ADDR(1, *ADDR(1,0));
  1331.             while (*ptr2 != slot)
  1332.                 ptr2 += *(ptr2 + 1) + 2;
  1333.             val2 = *(ptr2 + 1);/* # of relayed objects */
  1334.         }
  1335.         create(2 * val2 + 2, &bas1, &off1, &ptr1);
  1336.         *ptr1 = -SUBPROG(ptr)->cs;/* Not yet elab. */
  1337.         *(ptr1 + 1) = val2;
  1338.         PUSH_ADDR(bas1, off1);
  1339.         break;
  1340.  
  1341.     default:
  1342.         raise(SYSTEM_ERROR, "Creating object of unknown type");
  1343.     }
  1344. }
  1345.  
  1346. void create_copy_struc()                        /*;create_copy_struc*/
  1347. {
  1348.     POP_ADDR(bse, off);    /* type */
  1349.     ptr = ADDR(bse, off);
  1350.     POP_ADDR(bas2, off2);    /* value */
  1351.     ptr2 = ADDR(bas2, off2);
  1352.  
  1353.     val1 = TYPE(ptr);
  1354.     val2 = SIZE(ptr);
  1355.     create(val2, &bas1, &off1, &ptr1);
  1356.     PUSH_ADDR(bas1, off1);
  1357.  
  1358.     switch(val1) {
  1359.     case TT_U_ARRAY:
  1360.     case TT_C_ARRAY:
  1361.     case TT_S_ARRAY:
  1362.     case TT_D_ARRAY:
  1363.         if (val2 > 0) {    /* copy the object */
  1364.             for (i = 1; i <= val2; i++)
  1365.                 *ptr1++ = *ptr2++;
  1366.         }
  1367.         if (bse >= heap_base) {
  1368.             /* create new type template */
  1369.             val2 = *(ptr - WORDS_HDR) - WORDS_HDR;
  1370.             /* size of template */
  1371.             create(val2, &bas3, &off3, &ptr3);
  1372.             for (i = 1; i <= val2; i++)
  1373.                 *ptr3++ = *ptr++;
  1374.         }
  1375.         else {
  1376.             bas3 = bse;    /* static template, use same */
  1377.             off3 = off;
  1378.         }
  1379.         PUSH_ADDR(bas3, off3);
  1380.         break;
  1381.  
  1382.     case TT_RECORD:
  1383.     case TT_C_RECORD:
  1384.     case TT_U_RECORD:
  1385.     case TT_D_RECORD:
  1386.     case TT_V_RECORD:
  1387.         for (i = 1; i <= val2; i++)
  1388.             *ptr1++ = *ptr2++;
  1389.         break;
  1390.     }
  1391. }
  1392.  
  1393. void compare_struc()                                    /*;compare_struc*/
  1394. {
  1395.     POP_ADDR(bse, off);                    /* type */
  1396.     ptr3 = ADDR(bse, off);
  1397.     length1 = SIZE(ptr3);
  1398.     POP_ADDR(bse, off);                    /* first value */
  1399.     ptr1 = ADDR(bse, off);
  1400.  
  1401.     switch TYPE(ptr3) {        /* type of type */
  1402.     case TT_U_ARRAY:
  1403.     case TT_C_ARRAY:
  1404.     case TT_S_ARRAY:
  1405.     case TT_D_ARRAY:
  1406.         POP_ADDR(bse, off);         /* type of the other one */
  1407.         ptr4 = ADDR(bse, off);
  1408.         length2 = SIZE(ptr4);
  1409.         POP_ADDR(bse, off);            /* second value */
  1410.         if (length1 != length2) {
  1411.             PUSH(FALSE);
  1412.             return;
  1413.         }
  1414.         if (length1 == 0) {
  1415.             PUSH(TRUE);
  1416.             return;
  1417.         }
  1418.         if ((TYPE(ptr3) == TT_U_ARRAY || TYPE(ptr3) == TT_C_ARRAY)
  1419.             && !same_dimensions(ptr3, ptr4)) {
  1420.             PUSH(FALSE);
  1421.             return ;
  1422.         }
  1423.         ptr2 = ADDR(bse, off);
  1424.         break;
  1425.  
  1426.     case TT_RECORD:
  1427.     case TT_U_RECORD:
  1428.     case TT_C_RECORD:
  1429.     case TT_D_RECORD:
  1430.         POP_ADDR(bse, off);    /* second value */
  1431.         ptr2 = ADDR(bse, off);
  1432.         if (TYPE(ptr3) != TT_RECORD) {
  1433.             ptr1 += 1; /* skip constraint bit */
  1434.             ptr2 += 1;
  1435.             length1 -= 1;
  1436.         }
  1437.         /*
  1438.         else {
  1439.             PUSH (compare_fields_record (ptr1, ptr2, ptr3));
  1440.             return;
  1441.         }
  1442.         */
  1443.         break;
  1444.     }
  1445.  
  1446.     while (length1-- > 0) {
  1447.         val1 = *ptr1++;
  1448.         val2 = *ptr2++;
  1449.         if (val1 != val2) {
  1450.             PUSH(FALSE);
  1451.             return;
  1452.         }
  1453.     }
  1454.     PUSH(TRUE);
  1455. }
  1456.  
  1457. void compare_arrays()                                    /* compare_arrays */
  1458. {
  1459.     int eq_val;
  1460.     int inf_val;
  1461.  
  1462.     POP_ADDR(bse, off);             /* type */
  1463.     ptr3 = ADDR(bse, off);
  1464.     length1 = SIZE(ptr3);
  1465.     POP_ADDR(bse, off);             /* first value */
  1466.     ptr1 = ADDR(bse, off);
  1467.     POP_ADDR(bse, off);             /* type of the other one */
  1468.     ptr4 = ADDR(bse, off);
  1469.     length2 = SIZE(ptr4);
  1470.     POP_ADDR(bse, off);             /* second value */
  1471.     ptr2 = ADDR(bse, off);
  1472.     eq_val = (length1 == length2);
  1473.     inf_val = (length1 < length2);
  1474.     if (length1 <= length2) {
  1475.         if (length2 == 0) {
  1476.             eq_val  = 1;
  1477.             inf_val = 0;
  1478.         }
  1479.         else if (length1 == 0) {
  1480.             eq_val  = 0;
  1481.             inf_val = 1;
  1482.         }
  1483.         else {
  1484.             while (length1-- > 0) {
  1485.                 if ((val1 = *ptr1++) < (val2 = *ptr2++)) {
  1486.                     eq_val  = 0;
  1487.                     inf_val = 1;
  1488.                     break;
  1489.                 }
  1490.                 else if (val1 > val2) {
  1491.                     eq_val  = 0;
  1492.                     inf_val = 0;
  1493.                     break;
  1494.                 }
  1495.             }
  1496.         }
  1497.     }
  1498.     else {
  1499.         while (length2-- > 0) {
  1500.             if ((val2 = *ptr2++) > (val1 = *ptr1++)) {
  1501.                 eq_val  = 0;
  1502.                 inf_val = 1;
  1503.                 break;
  1504.             }
  1505.             else if (val2 < val1) {
  1506.                 eq_val  = 0;
  1507.                 inf_val = 0;
  1508.                 break;
  1509.             }
  1510.             else if (length2 == 0) {
  1511.                 eq_val  = 0;
  1512.                 inf_val = 0;
  1513.             }
  1514.         }
  1515.     }
  1516.     PUSH(eq_val+2*inf_val);
  1517. }
  1518.  
  1519. void array_slice()                                        /*;array_slice*/
  1520. {
  1521.     int     low_bound, high_bound, length;
  1522.  
  1523.     POP_ADDR(bse, off);    /* type */
  1524.     ptr = ADDR(bse, off);
  1525.     POP_ADDR(bas1, off1);    /* value */
  1526.  
  1527.     /* extract bounds and size of component */
  1528.  
  1529.     if (TYPE(ptr) == TT_S_ARRAY) {
  1530.         component_size = S_ARRAY(ptr)->component_size;
  1531.         high_bound = S_ARRAY(ptr)->sahigh;
  1532.         low_bound = S_ARRAY(ptr)->salow;
  1533.     }
  1534.     else if (TYPE(ptr) == TT_C_ARRAY) {
  1535.         bse = ARRAY(ptr)->component_base;
  1536.         off = ARRAY(ptr)->component_offset;
  1537.         component_size = SIZE(ADDR(bse, off));
  1538.         bse = ARRAY(ptr)->index1_base;
  1539.         off = ARRAY(ptr)->index1_offset;
  1540.         high_bound = I_RANGE(ADDR(bse, off))->ihigh;
  1541.         low_bound = I_RANGE(ADDR(bse, off))->ilow;
  1542.     }
  1543.  
  1544.     POP(val_high);
  1545.     POP(val_low);
  1546.     if (val_high < val_low)                /* make null slice if null */
  1547.         length = 0;
  1548.     else if (val_high > high_bound || val_low < low_bound) {
  1549.         raise(CONSTRAINT_ERROR, "Slice index out of bounds");
  1550.         return;
  1551.     }
  1552.     else
  1553.         length = val_high - val_low + 1;
  1554.     size = length * component_size;
  1555.     off1 = off1 + (val_low - low_bound) * component_size;
  1556.     PUSH_ADDR(bas1, off1);
  1557.  
  1558.     create(WORDS_S_ARRAY, &bse, &off, &ptr);
  1559.     S_ARRAY(ptr)->ttype = TT_S_ARRAY;
  1560.     S_ARRAY(ptr)->object_size = size;
  1561.     S_ARRAY(ptr)->component_size = component_size;
  1562.     S_ARRAY(ptr)->index_size = 1;
  1563.     S_ARRAY(ptr)->salow = val_low;
  1564.     S_ARRAY(ptr)->sahigh = val_high;
  1565.     PUSH_ADDR(bse, off);
  1566. }
  1567.  
  1568. /* ARRAY_CATENATE */
  1569.  
  1570. void array_catenate()                                    /*;array_catenate*/
  1571. {
  1572.     int     catsize, val_low, val_high, rlow, rhigh, index_kind;
  1573.  
  1574.     POP_ADDR(bse, off);    /* type of result for qual */
  1575.     ptr = ADDR(bse, off);
  1576.  
  1577.     /* right argument */
  1578.  
  1579.     POP_ADDR(bas1, off1);    /* type of right arg */
  1580.     ptr1 = ADDR(bas1, off1);
  1581.     POP_ADDR(bas2, off2);    /* right arg */
  1582.     ptr2 = ADDR(bas2, off2);
  1583.  
  1584.     /* left operand */
  1585.  
  1586.     POP_ADDR(bas3, off3);    /* type */
  1587.     ptr3 = ADDR(bas3, off3);
  1588.     POP_ADDR(bas4, off4);
  1589.     ptr4 = ADDR(bas4, off4);
  1590.  
  1591.     /* empty arrays */
  1592.  
  1593.     if ((length2 = SIZE(ptr3)) == 0) {
  1594.         PUSH_ADDR(bas2, off2);
  1595.         PUSH_ADDR(bas1, off1);
  1596.         return;            /* result is right operand */
  1597.     }
  1598.     if ((length1 = SIZE(ptr1)) == 0) {
  1599.         PUSH_ADDR(bas4, off4);
  1600.         PUSH_ADDR(bas3, off3);
  1601.         return;            /* result is left operand */
  1602.     }
  1603.  
  1604.     /* get lower bound of left */
  1605.  
  1606.     if (*ptr3 == TT_S_ARRAY) {
  1607.         val_low = S_ARRAY(ptr3)->salow;
  1608.         index_kind = S_ARRAY(ptr3)->index_size;
  1609.         component_size = S_ARRAY(ptr3)->component_size;
  1610.     }
  1611.  
  1612.     else if (*ptr3 == TT_C_ARRAY || *ptr3 == TT_U_ARRAY) {
  1613.         component_size = SIZE(ADDR(ARRAY(ptr3)->component_base,
  1614.           ARRAY(ptr3)->component_offset));
  1615.         val_low = I_RANGE(ADDR(ARRAY(ptr3)->index1_base,
  1616.           ARRAY(ptr3)->index1_offset))->ilow;
  1617.         index_kind = SIZE(ADDR(ARRAY(ptr3)->index1_base,
  1618.           ARRAY(ptr3)->index1_offset));
  1619.     }
  1620.  
  1621.     catsize = length2 + length1;
  1622.     val_high = val_low +(catsize / component_size) - 1;
  1623.  
  1624.     /* get bounds of result */
  1625.  
  1626.     if (*ptr == TT_S_ARRAY) {
  1627.         rlow = S_ARRAY(ptr)->salow;
  1628.         rhigh = S_ARRAY(ptr)->sahigh;
  1629.     }
  1630.     else if (*ptr == TT_C_ARRAY || *ptr == TT_U_ARRAY) {
  1631.         rlow = I_RANGE(ADDR(ARRAY(ptr)->index1_base,
  1632.           ARRAY(ptr)->index1_offset))->ilow;
  1633.         rhigh = I_RANGE(ADDR(ARRAY(ptr)->index1_base,
  1634.           ARRAY(ptr)->index1_offset))->ihigh;
  1635.     }
  1636.  
  1637.     /* check bounds */
  1638.  
  1639.     if (val_low < rlow || val_high > rhigh) {
  1640.         raise(CONSTRAINT_ERROR, "Array catenate");
  1641.         return;
  1642.     }
  1643.  
  1644.     /* everything ok: do the job */
  1645.  
  1646.     create(catsize, &bse, &off, &ptr);
  1647.     for (i = 0; i < length2; i++)
  1648.         *ptr++ = *ptr4++;
  1649.     for (i = 0; i < length1; i++)
  1650.         *ptr++ = *ptr2++;
  1651.  
  1652.     PUSH_ADDR(bse, off);
  1653.  
  1654.     create(WORDS_S_ARRAY, &bse, &off, &ptr);
  1655.     S_ARRAY(ptr)->ttype = TT_S_ARRAY;
  1656.     S_ARRAY(ptr)->object_size = catsize;
  1657.     S_ARRAY(ptr)->component_size = component_size;
  1658.     S_ARRAY(ptr)->index_size = index_kind;
  1659.     S_ARRAY(ptr)->salow = val_low;
  1660.     S_ARRAY(ptr)->sahigh = val_high;
  1661.     PUSH_ADDR(bse, off);
  1662. }
  1663.  
  1664. void subscript()                                                /*;subscript*/
  1665. {
  1666.     POP_ADDR(bas1, off1);    /* type */
  1667.     POP_ADDR(bse, off);    /* array */
  1668.     ptr1 = ADDR(bas1, off1);
  1669.  
  1670.     val1 = TYPE(ptr1);        /* type of type */
  1671.     if (val1 == TT_S_ARRAY) {
  1672.         POP(value);
  1673.         val2 = S_ARRAY(ptr1)->component_size;
  1674.         val_low = S_ARRAY(ptr1)->salow;
  1675.         val_high = S_ARRAY(ptr1)->sahigh;
  1676.         if (value < val_low || value > val_high)
  1677.             raise(CONSTRAINT_ERROR, "Index out of bounds");
  1678.         result = (value - val_low) * val2;
  1679.     }
  1680.  
  1681.     else if ((val1 == TT_C_ARRAY) ||(val1 == TT_U_ARRAY)) {
  1682.         bas1 = ARRAY(ptr1)->component_base;
  1683.         off1 = ARRAY(ptr1)->component_offset;
  1684.         val1 = SIZE(ADDR(bas1, off1));/* size of component */
  1685.         val2 = ARRAY(ptr1)->dim;
  1686.         result = 0;
  1687.         delta = 1;
  1688.         ptr1 = &(ARRAY(ptr1)->index1_base);
  1689.         for (i = 1; i <= val2; i++) {
  1690.             POP(value);
  1691.             bas2 = *ptr1++;
  1692.             off2 = *ptr1++;
  1693.             ptr2 = ADDR(bas2, off2);
  1694.             val_low = I_RANGE(ptr2)->ilow;
  1695.             val_high = I_RANGE(ptr2)->ihigh;
  1696.             if (value < val_low || value > val_high) {
  1697.                 raise(CONSTRAINT_ERROR, "Index out of bounds");
  1698.             }
  1699.             value = value - val_low;
  1700.             result = (value * delta) + result;
  1701.             delta = delta *(val_high - val_low + 1);
  1702.         }
  1703.         result = result * val1;
  1704.     }
  1705.     else
  1706.         raise(SYSTEM_ERROR, "Illegal array type");
  1707.     off += result;
  1708.     PUSH_ADDR(bse, off);
  1709. }
  1710.  
  1711. void array_move()                                                /*;array_move*/
  1712. {
  1713.     POP_ADDR(bse, off);    /* type of the value */
  1714.     ptr1 = ADDR(bse, off);
  1715.     POP_ADDR(bse, off);    /* value */
  1716.     ptr2 = ADDR(bse, off);
  1717.  
  1718.     POP_ADDR(bse, off);    /* type of the object */
  1719.     ptr3 = ADDR(bse, off);
  1720.     POP_ADDR(bse, off);    /*  object */
  1721.     ptr4 = ADDR(bse, off);
  1722.  
  1723.     length1 = SIZE(ptr1);
  1724.     length2 = SIZE(ptr3);
  1725.     /* : The test of the length equalities has to be done at first otherwise
  1726.      * "a := b" will be valid if a is a null array and b a non null one
  1727.      */
  1728.     if (length1 != length2)
  1729.         raise(CONSTRAINT_ERROR, "Arrays not same length");
  1730.     else if (length1 == 0) return; /* null array */
  1731.     else {
  1732.         if (ptr4 < ptr2) {
  1733.             for (i = 0; i <= length2 - 1; i++)    /* copy in ascending order */
  1734.                 *(ptr4 + i) = *(ptr2 + i);
  1735.         }
  1736.         else {
  1737.             ptr4 += length2;    /* copy in descending order */
  1738.             ptr2 += length2;
  1739.             for (i = 1; i <= length2; i++)
  1740.                 *(ptr4 - i) = *(ptr2 - i);
  1741.         }
  1742.     }
  1743. }
  1744.  
  1745. static int same_dimensions(int *temp1, int *temp2)        /*;same_dimensions */
  1746. {
  1747.     int *p1, *p2, *p3 ;
  1748.     int low1, low2, high1, high2;
  1749.     int d ;
  1750.     /* When comparing multidimensional arrays, must check that they have
  1751.      * the same dimensions (otherwise a 2 by 3 array might check equal to a
  1752.      * 3 by 2 array. See c34005m).
  1753.      */
  1754.  
  1755.     d = ARRAY(temp1)->dim;
  1756.     if (d == 1) return (TRUE) ;
  1757.     p1 = &(ARRAY(temp1)->index1_base);
  1758.     p2 = &(ARRAY(temp2)->index1_base);
  1759.     for (i = 1; i <= d; i++) {
  1760.         bas1  = *p1++;
  1761.         off1  = *p1++;
  1762.         p3    = ADDR(bas1, off1);        /* template of 1st index type */
  1763.         low1  = I_RANGE(p3)->ilow;
  1764.         high1 = I_RANGE(p3)->ihigh;
  1765.  
  1766.         bas2  = *p2++;
  1767.         off2  = *p2++;
  1768.         p3    = ADDR(bas2, off2);        /* template of 2nd index type */
  1769.         low2  = I_RANGE(p3)->ilow;
  1770.         high2 = I_RANGE(p3)->ihigh;
  1771.         if (high1 - low1 != high2 - low2)
  1772.             return (FALSE) ;
  1773.     }
  1774.     return TRUE ;
  1775. }
  1776.  
  1777. static int compare_fields_record (int *v_ptr1, int *v_ptr2, int *itemplate)
  1778.                                                     /*;compare_fields_record*/
  1779. {
  1780.     /* this procedure allows the comparison of record.
  1781.      * The comparison is not straightfoward if one in unconstrained
  1782.      * and the other is constrained or if there are variant parts.
  1783.      * This procedure was not intended to be completed. It was just a
  1784.      * test  to solve one acv test of c3.
  1785.      * This procedure is not called from the Ada machine because it
  1786.      * slows down the comparison.
  1787.      * Nevertheless, this case has to be taken into account for future
  1788.      * work
  1789.     */
  1790.     int length1, *ptr1, *ptr2 ;
  1791.     int i, nb_field, type_base, type_off, *type_ptr, *field_ptr;
  1792.     int field_offset;
  1793.  
  1794.     ptr1 = v_ptr1;
  1795.     ptr2 = v_ptr2;
  1796.  
  1797.     switch TYPE (itemplate) {
  1798.     case TT_RECORD:
  1799.         nb_field = RECORD(itemplate)->nb_field;
  1800.         field_ptr = itemplate + WORDS_RECORD;
  1801.         for (i = 1; i <= nb_field; i++) {
  1802.             field_offset = *field_ptr;
  1803.             field_ptr = field_ptr + 1;
  1804.             type_base = *field_ptr;
  1805.             type_off = *++field_ptr;
  1806.             type_ptr = ADDR(type_base, type_off);
  1807.             if (!compare_fields_record (v_ptr1 + field_offset,
  1808.                 v_ptr2 + field_offset, type_ptr)) {
  1809.                 return FALSE;
  1810.             }
  1811.             field_ptr++;
  1812.         }
  1813.         return TRUE;
  1814.  
  1815.     case TT_U_RECORD:
  1816.     case TT_C_RECORD:
  1817.     case TT_D_RECORD:
  1818.         length1 = SIZE (itemplate);
  1819.         ptr1 += 1; /* skip constraint bit */
  1820.         ptr2 += 1;
  1821.         length1 -= 1;
  1822.         break;
  1823.  
  1824.     default:
  1825.         length1 = SIZE (itemplate);
  1826.         break;
  1827.     }
  1828.     while (length1-- > 0) {
  1829.         val1 = *ptr1++;
  1830.         val2 = *ptr2++;
  1831.         if (val1 != val2)
  1832.             return FALSE;
  1833.     }
  1834.     return TRUE;
  1835. }
  1836.